home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xscheme.arc / xsinit.c < prev    next >
C/C++ Source or Header  |  1989-01-29  |  8KB  |  228 lines
  1. /* xsinit.c - xscheme initialization routines */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7. #include "xsbcode.h"
  8.  
  9. /* macro to store a byte into a bytecode vector */
  10. #define pb(x)    (*bcode++ = (x))
  11.  
  12. /* global variables */
  13. LVAL lk_optional,lk_rest;
  14. LVAL obarray,true,eof_object,default_object,s_unassigned;
  15. LVAL cs_map1,cs_foreach1,cs_withfile1,cs_load1,cs_force1;
  16. LVAL c_lpar,c_rpar,c_dot,c_quote,s_quote;
  17. LVAL s_eval,s_unbound,s_stdin,s_stdout,s_stderr;
  18. LVAL s_printcase,k_upcase,k_downcase;
  19. LVAL s_fixfmt,s_flofmt;
  20.  
  21. /* external variables */
  22. extern jmp_buf top_level;
  23. extern FUNDEF funtab[];
  24. extern int xsubrcnt;
  25. extern int csubrcnt;
  26.  
  27. /* xlinitws - create an initial workspace */
  28. xlinitws(ssize)
  29.   unsigned int ssize;
  30. {
  31.     unsigned char *bcode;
  32.     int type,i;
  33.     LVAL code;
  34.     FUNDEF *p;
  35.  
  36.     /* setup an initialization error handler */
  37.     if (setjmp(top_level))
  38.     exit(1);
  39.  
  40.     /* allocate memory for the workspace */
  41.     xlminit(ssize);
  42.  
  43.     /* initialize the obarray */
  44.     obarray = cvsymbol("*OBARRAY*");
  45.     setvalue(obarray,newvector(HSIZE));
  46.  
  47.     /* add the symbol *OBARRAY* to the obarray */
  48.     setelement(getvalue(obarray),
  49.                hash(getstring(getpname(obarray)),HSIZE),
  50.                cons(obarray,NIL));
  51.  
  52.     /* enter the eof object */
  53.     eof_object = cons(xlenter("**EOF**"),NIL);
  54.     
  55.     /* enter the default object */
  56.     default_object = cons(xlenter("**DEFAULT**"),NIL);
  57.  
  58.     /* initialize the error handlers */
  59.     setvalue(xlenter("*ERROR-HANDLER*"),NIL);
  60.     setvalue(xlenter("*UNBOUND-HANDLER*"),NIL);
  61.     
  62.     /* install the built-in functions */
  63.     for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p) {
  64.     type = (i < xsubrcnt ? XSUBR : (i < csubrcnt ? CSUBR : SUBR));
  65.     xlsubr(p->fd_name,type,p->fd_subr,i);
  66.     }
  67.     xloinit(); /* initialize xsobj.c */
  68.  
  69.     /* setup some synonyms */
  70.     setvalue(xlenter("NOT"),getvalue(xlenter("NULL?")));
  71.     setvalue(xlenter("PRIN1"),getvalue(xlenter("WRITE")));
  72.     setvalue(xlenter("PRINC"),getvalue(xlenter("DISPLAY")));
  73.  
  74.     /* enter all of the symbols used by the runtime system */
  75.     xlsymbols();
  76.  
  77.     /* set the initial values of the symbols #T, T and NIL */
  78.     setvalue(true,true);
  79.     setvalue(xlenter("T"),true);
  80.     setvalue(xlenter("NIL"),NIL);
  81.  
  82.     /* default to lowercase output of symbols */
  83.     setvalue(s_printcase,k_downcase);
  84.  
  85.     /* setup the print formats for numbers */
  86.     s_fixfmt = xlenter("*FIXNUM-FORMAT*");
  87.     setvalue(s_fixfmt,cvstring(IFMT));
  88.     s_flofmt = xlenter("*FLONUM-FORMAT*");
  89.     setvalue(s_flofmt,cvstring(FFMT));
  90.     
  91.     /* build the 'eval' function */
  92.     code = newcode(4); cpush(code);
  93.     setelement(code,0,newstring(0x12));
  94.     setelement(code,1,xlenter("EVAL"));
  95.     setelement(code,2,cons(xlenter("X"),NIL));
  96.     setelement(code,3,xlenter("COMPILE"));
  97.     drop(1);
  98.  
  99.     /* store the byte codes */
  100.     bcode = (unsigned char *)getstring(getbcode(code));
  101.  
  102. pb(OP_FRAME);pb(0x02);        /* 0000 12 02    FRAME 02        */
  103. pb(OP_MVARG);pb(0x01);        /* 0002 13 01    MVARG 01        */
  104. pb(OP_ALAST);            /* 0004 1a       ALAST            */
  105. pb(OP_SAVE);pb(0x00);pb(0x10);    /* 0005 0b 00 10 SAVE 0010        */
  106. pb(OP_EREF);pb(0x00);pb(0x01);    /* 0008 09 00 01 EREF 00 01 ; x        */
  107. pb(OP_PUSH);            /* 000b 10       PUSH            */
  108. pb(OP_GREF);pb(0x03);        /* 000c 05 03    GREF 03 ; compile    */
  109. pb(OP_CALL);pb(0x01);        /* 000e 0c 01    CALL 01        */
  110. pb(OP_CALL);pb(0x00);        /* 0010 0c 00    CALL 00        */
  111.  
  112.     setvalue(getelement(code,1),cvclosure(code,NIL));
  113.  
  114.     /* setup the initialization code */
  115.     code = newcode(6); cpush(code);
  116.     setelement(code,0,newstring(0x11));
  117.     setelement(code,1,xlenter("*INITIALIZE*"));
  118.     setelement(code,3,cvstring("xscheme.ini"));
  119.     setelement(code,4,xlenter("LOAD"));
  120.     setelement(code,5,xlenter("*TOPLEVEL*"));
  121.     drop(1);
  122.  
  123.     /* store the byte codes */
  124.     bcode = (unsigned char *)getstring(getbcode(code));
  125.  
  126. pb(OP_FRAME);pb(0x01);        /* 0000 12 01    FRAME 01        */
  127. pb(OP_ALAST);            /* 0002 1a       ALAST            */
  128. pb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d        */
  129. pb(OP_LIT);  pb(0x03);        /* 0006 04 03    LIT 03 ; "xscheme.ini"    */
  130. pb(OP_PUSH);            /* 0008 10       PUSH            */
  131. pb(OP_GREF); pb(0x04);        /* 0009 05 04    GREF 04 ; load        */
  132. pb(OP_CALL); pb(0x01);        /* 000b 0c 01    CALL 01        */
  133. pb(OP_GREF); pb(0x05);        /* 000d 05 05    GREF 05 ; *toplevel*    */
  134. pb(OP_CALL); pb(0x00);        /* 000f 0c 00    CALL 00        */
  135.  
  136.     setvalue(getelement(code,1),cvclosure(code,NIL));
  137.  
  138.     /* setup the main loop code */
  139.     code = newcode(9); cpush(code);
  140.     setelement(code,0,newstring(0x28));
  141.     setelement(code,1,xlenter("*TOPLEVEL*"));
  142.     setelement(code,3,cvstring("\n> "));
  143.     setelement(code,4,xlenter("DISPLAY"));
  144.     setelement(code,5,xlenter("READ"));
  145.     setelement(code,6,xlenter("EVAL"));
  146.     setelement(code,7,xlenter("WRITE"));
  147.     setelement(code,8,xlenter("*TOPLEVEL*"));
  148.     drop(1);
  149.  
  150.     /* store the byte codes */
  151.     bcode = (unsigned char *)getstring(getbcode(code));
  152.  
  153. pb(OP_FRAME);pb(0x01);        /* 0000 12 01    FRAME 01        */
  154. pb(OP_ALAST);            /* 0002 1a       ALAST            */
  155. pb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d        */
  156. pb(OP_LIT);  pb(0x03);        /* 0006 04 03    LIT 03 ; "\n> "        */
  157. pb(OP_PUSH);            /* 0008 10       PUSH            */
  158. pb(OP_GREF); pb(0x04);        /* 0009 05 04    GREF 04 ; display    */
  159. pb(OP_CALL); pb(0x01);        /* 000b 0c 01    CALL 01        */
  160. pb(OP_SAVE); pb(0x00); pb(0x24);/* 000d 0b 00 24 SAVE 0024        */
  161. pb(OP_SAVE); pb(0x00); pb(0x1f);/* 0010 0b 00 1f SAVE 001f        */
  162. pb(OP_SAVE); pb(0x00); pb(0x1a);/* 0013 0b 00 1a SAVE 001a        */
  163. pb(OP_GREF); pb(0x05);        /* 0016 05 05    GREF 05 ; read        */
  164. pb(OP_CALL); pb(0x00);        /* 0018 0c 00    CALL 00        */
  165. pb(OP_PUSH);            /* 001a 10       PUSH            */
  166. pb(OP_GREF); pb(0x06);        /* 001b 05 06    GREF 06 ; eval        */
  167. pb(OP_CALL); pb(0x01);        /* 001d 0c 01    CALL 01        */
  168. pb(OP_PUSH);            /* 001f 10       PUSH            */
  169. pb(OP_GREF); pb(0x07);        /* 0020 05 07    GREF 07 ; write    */
  170. pb(OP_CALL); pb(0x01);        /* 0022 0c 01    CALL 01        */
  171. pb(OP_GREF); pb(0x08);        /* 0024 05 08    GREF 08 ; *toplevel*    */
  172. pb(OP_CALL); pb(0x00);        /* 0026 0c 00    CALL 00        */
  173.  
  174.     setvalue(getelement(code,1),cvclosure(code,NIL));
  175. }
  176.  
  177. /* xlsymbols - lookup/enter all symbols used by the runtime system */
  178. xlsymbols()
  179. {
  180.     LVAL sym;
  181.     
  182.     /* top-level procedure symbol */
  183.     s_eval = xlenter("EVAL");
  184.     
  185.     /* enter the symbols used by the system */
  186.     true         = xlenter("#T");
  187.     s_unbound     = xlenter("*UNBOUND*");
  188.     s_unassigned = xlenter("#!UNASSIGNED");
  189.     s_stdin     = xlenter("*STANDARD-INPUT*");
  190.     s_stdout     = xlenter("*STANDARD-OUTPUT*");
  191.     s_stderr     = xlenter("*ERROR-OUTPUT*");
  192.     
  193.     /* enter the lambda list keywords */
  194.     lk_optional = xlenter("#!OPTIONAL");
  195.     lk_rest     = xlenter("#!REST");
  196.  
  197.     /* enter symbols needed by the reader */
  198.     c_lpar   = xlenter("(");
  199.     c_rpar   = xlenter(")");
  200.     c_dot    = xlenter(".");
  201.     c_quote  = xlenter("'");
  202.     s_quote  = xlenter("QUOTE");
  203.  
  204.     /* 'else' is a useful synonym for #t in cond clauses */
  205.     sym = xlenter("ELSE");
  206.     setvalue(sym,true);
  207.  
  208.     /* setup stdin/stdout/stderr */
  209.     setvalue(s_stdin,cvport(stdin,PF_INPUT));
  210.     setvalue(s_stdout,cvport(stdout,PF_OUTPUT));
  211.     setvalue(s_stderr,cvport(stderr,PF_OUTPUT));
  212.  
  213.     /* enter *print-case* and its keywords */
  214.     k_upcase    = xlenter("UPCASE");
  215.     k_downcase    = xlenter("DOWNCASE");
  216.     s_printcase    = xlenter("*PRINT-CASE*");
  217.  
  218.     /* get the built-in continuation subrs */
  219.     cs_map1 = getvalue(xlenter("%MAP1"));
  220.     cs_foreach1 = getvalue(xlenter("%FOR-EACH1"));
  221.     cs_withfile1 = getvalue(xlenter("%WITH-FILE1"));
  222.     cs_load1 = getvalue(xlenter("%LOAD1"));
  223.     cs_force1 = getvalue(xlenter("%FORCE1"));
  224.  
  225.     /* initialize xsobj.c */
  226.     obsymbols();
  227. }
  228.